(*
This unit is part of TArtFormula package.
See formula.pas for notes, License and disclaimer agreement.

(c) Artem V. Parlyuk, e-mail:artsoft@nm.ru, http://artsoft.nm.ru
*)
unit formulan;

interface
uses SysUtils, classes;

type

 TFormulaError = (ER_Ok, ER_ILLEGAL, ER_UNKNOWN, ER_RIGHT, ER_LEFT, ER_SYNTAX, ER_VARS,
   ER_NOTENOUGH);

 FormulaException = class(Exception)
 end;
 TArtFormulaN = class;

 TFormulaStackN = class
 protected
  max,pos : integer;
  data : array of char;
  Parent : TArtFormulaN;
 public
  constructor Create(i:integer=256);
  destructor Free;
  property Num : integer read pos;
  function Top : char;
  procedure Push(c : char);
  function Pop:char;
  function PopEx : string;
  function Item(i:integer) : char;
 end;

 pformulafunctionN = function(pos : integer; var data : array of double) : double;

 StringArray = array of String;
 DoubleArray = array of double;
 PStringArray = ^StringArray;
 PDoubleArray = ^DoubleArray;

 FTableItem = record
      name : string;
      paramcount : integer;
      fun : pformulafunctionN;
 end;

 TConstItem = record
  name, value : string;
 end;

TArtFormulaN = class(TComponent)
  protected
   max,cpos : integer;
   cdata : array of double;
   pos, numofvar : integer;
   ferror : TFormulaError;
   ftestused : boolean;
   fcompiled : string;
   fcasesensitive : boolean;
   S : TFormulaStackN;
   input : string;
   temp : string;
   varnames : PStringArray;
   data : double;
   usedvars : array of boolean;
   userfunc : array of FTableItem;
   ConstTable : array of TConstItem;
   formula_err : TFormulaError;
   function Parser(flag:boolean=false) : integer;
   function Form: integer;
   function ErrString: string;
  public
   property Error : TFormulaError read ferror;
   property ErrPos : integer read pos;
   property Compiled : string read fcompiled;

   constructor Create(AOwner: TComponent); override;
   destructor Free;

   procedure AddUserFunction(name : string; paramcount:integer; fun : pformulafunctionN);
   procedure AddUserConstant(name, value : string);

   function Test(instr : string; num : byte = 0; vars : PStringArray = nil) : boolean;
   function Compile(instr : string; num : byte = 0; vars : PStringArray = nil) : string;
   function Compute(vals : PDoubleArray = nil) : double;
   function ComputeStr(instr : string; num : byte = 0; vars : PStringArray = nil; vals : pdoublearray = nil) : double;
  published
   property TestUsed : boolean read ftestused write ftestused;
   property CaseSensitive : boolean read fcasesensitive write fcasesensitive;
end;

procedure Register;

implementation

{$J+}

uses math, formulanf;

const
 F_EOS = -1;
 F_DATA = 254;
 F_VAR = 253;
 F_NE = #252;
 F_UMINUS = #251;
 F_GE = #250;
 F_LE = #249;
 F_USERF = #248;

 NUMFUN = 33;

const
 table : array [0..NUMFUN-1] of FTableItem =
(
 (name:''),
 (name:'SIN'; paramcount:1;fun:mysin),
 (name:'COS';paramcount:1;fun:mycos),
 (name:'TAN';paramcount:1;fun:mytan),
 (name:'LOG';paramcount:1;fun:mylog),
 (name:'LG';paramcount:1;fun:mylg),
 (name:'EXP';paramcount:1;fun:myexp),
 (name:'SQRT';paramcount:1;fun:mysqrt),
 (name:'INT';paramcount:1;fun:myint),
 (name:'FRAC';paramcount:1;fun:myfrac),
 (name:'ABS';paramcount:1;fun:myabs),
 (name:'ATAN';paramcount:1;fun:myatan),
 (name:'ASIN';paramcount:1;fun:myasin),
 (name:'ACOS';paramcount:1;fun:myacos),
 (name:'ASINH';paramcount:1;fun:myasinh),
 (name:'ACOSH';paramcount:1;fun:myacosh),
 (name:'ATANH';paramcount:1;fun:myatanh),
 (name:'COSH';paramcount:1;fun:mycosh),
 (name:'SINH';paramcount:1;fun:mysinh),
 (name:'TANH';paramcount:1;fun:mytanh),
 (name:'SIGN';paramcount:1;fun:mysign),
 (name:'RND';paramcount:0;fun:myrnd),
 (name:'MAX';paramcount:-1;fun:mymax),
 (name:'MIN';paramcount:-1;fun:mymin),
 (name:'AVG';paramcount:-1;fun:myavg),
 (name:'STDDEV';paramcount:-1;fun:mystddev),
 (name:'STDDEVP';paramcount:-1;fun:mystddevp),
 (name:'SUM';paramcount:-1;fun:mysum),
 (name:'SUMOFSQUARES';paramcount:-1;fun:mysumofsquares),
 (name:'COUNT';paramcount:-1;fun:mycount),
 (name:'VARIANCE';paramcount:-1;fun:myvar),
 (name:'VARIANCEP';paramcount:-1;fun:myvarp),
 (name:'IFF';paramcount:3;fun:myiff)
 );

function isznak(c : char) : boolean;
begin
 result := c in ['+','-','*','/','%','^','>','<','=','&','|',F_NE,F_LE,F_GE];
end;

function isfun(c : char) : boolean;
begin
 result := ((c > #0)and(byte(c) < NUMFUN));
end;


constructor TFormulaStackN.Create(i : integer = 256);
begin
 max := i;
 pos := 0;
 setlength(data,i);
end;

destructor TFormulaStackN.Free;
begin
 data := nil;
end;

function TFormulaStackN.Top : char;
begin
 if pos > 0 then result := data[pos - 1]
 else result := #0;
end;

procedure TFormulaStackN.Push(c : char);
begin
 if pos = max then
 begin
  inc(max, 256);
  setlength(data,max);
 end;
 data[pos] := c;
 inc(pos);
end;

function TFormulaStackN.Pop : char;
begin
if pos > 0 then
begin
 dec(pos);
 result := data[pos];
end
else result := #0;
end;

function TFormulaStackN.PopEx : string;
begin
if pos > 0 then
begin
 dec(pos);
 if data[pos] = F_USERF then
 begin
  result := F_USERF + data[pos-1] + chr(Parent.userfunc[byte(data[pos-1])].paramcount);
  dec(pos);
 end
 else
 if isfun(data[pos]) then
  result := data[pos] + chr(table[byte(data[pos])].paramcount)
 else result := data[pos];
end
else result := #0;
end;


function TFormulaStackN.Item(i:integer) : char;
begin
 if (i >= 0) and (i < pos) then result := data[i]
 else result := #0;
end;

function prior(a,b : char) : boolean;
var pa,pb:integer;
begin
 if isfun(a) then pa := 1
 else if a = '^' then pa := 2
 else if a in ['!',F_UMINUS] then pa := 3
 else if a in ['*','/','%'] then pa := 4
 else if a in ['+','-'] then pa := 5
 else if a in ['|','&'] then pa := 6
 else if a in ['<','>','=',F_NE,F_GE,F_LE] then pa := 7
 else if a in ['(',')'] then pa := 8
 else pa := 100;

 if isfun(b) then pb := 1
 else if b = '^' then pb := 2
 else if b in ['!',F_UMINUS] then pb := 3
 else if b in ['*','/','%'] then pb := 4
 else if b in ['+','-'] then pb := 5
 else if b in ['|','&'] then pb := 6
 else if b in ['<','>','=',F_NE,F_GE,F_LE] then pb := 7
 else if b in ['(',')'] then pb := 8
 else pb := 100;

 result := pa >= pb;

end;

destructor TArtFormulaN.Free;
begin
 S.Free;
 usedvars := nil;
 userfunc := nil;
 cdata := nil;
 inherited Free;
end;

constructor TArtFormulaN.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 pos := 1;
 ferror := ER_Ok;
 input :=#0;
 usedvars := nil;
 S := TFormulaStackN.Create();
 S.Parent := self;
 max := 128;
 cpos := 0;
 setlength(cdata,128);
 AddUserConstant('PI','3.1415926535897932385');
 AddUserConstant('FALSE','0');
 AddUserConstant('TRUE','1');
end;

procedure TArtFormulaN.AddUserFunction(name : string; paramcount:integer; fun : pformulafunctionN);
var i:integer;
begin
 for i := 0 to high(table) do
  if uppercase(name) = table[i].name then
  raise FormulaException.Create('Function already defined');
 for i := 0 to high(userfunc) do
  if uppercase(name) = userfunc[i].name then
  raise FormulaException.Create('Function already defined');
 i := high(userfunc)+1;
 if i = 255 then raise FormulaException.Create('To many user functions defined');
 setlength(userfunc,i+1);
 userfunc[i].name := uppercase(name);
 userfunc[i].paramcount := paramcount;
 userfunc[i].fun := fun;
end;

procedure TArtFormulaN.AddUserConstant(name,value : string);
var i:integer;
begin
 for i := 0 to high(consttable) do
  if uppercase(name) = consttable[i].name then
  raise FormulaException.Create('Constant already defined');
 i := high(consttable)+1;
 setlength(consttable,i+1);
 consttable[i].name := uppercase(name);
 consttable[i].value := value;
end;

function TArtFormulaN.Parser(flag:boolean): integer;
var tmp,s : string;
    i : integer;
    c : char;
begin
 ferror := ER_Ok;
 c := input[pos];
 tmp := '';
 if c in [' ',#9,#10,#13] then
 begin
  repeat
   inc(pos);
   c := input[pos];
  until not (c in [' ',#9,#10,#13]);
 end;

 if c = '{' then
 begin
  inc(pos);
  c := input[pos];
  while (c <> '}') and (c <> #0) do
  begin
   inc(pos);
   c := input[pos];
  end;
  while (c = '}') or (c in [' ',#9,#10,#13]) do
  begin
   inc(pos);
   c := input[pos];
  end;
 end;

 if c = #0 then
 begin
  result := F_EOS;
  exit;
 end;

 if flag then
 begin
  result := byte(c);
  exit;
 end;

 if(((c >= 'A')and(c <= 'Z'))or((c >= 'a')and(c <= 'z'))) then
 begin
  repeat
   if not fcasesensitive and (c >= 'a')and(c <= 'z') then
     c := chr(ord(c) + ord('A') - ord('a'));
   tmp := tmp + c;
   inc(pos);
   c := input[pos];
  until not(((c >= 'A')and(c <= 'Z'))or((c >= 'a')and(c <= 'z'))or
        ((c <= '9')and(c >= '0')));

  for i := 0 to high(ConstTable) do
  begin
   if uppercase(tmp) = consttable[i].name then
   begin
    input := copy(input,1,pos-1)+ consttable[i].value + copy(input,pos,length(input)-pos+1);
    result := Parser;
    exit;
   end;
  end;

  for i := 1 to NUMFUN - 1 do
   if uppercase(tmp) = table[i].name then
   begin
      result := i;
      exit;
   end;

  for i := 0 to high(userfunc) do
   if uppercase(tmp) = userfunc[i].name then
   begin
      result := byte(F_USERF);
      data := i;
      exit;
   end;

  for i := 0 to numofvar - 1 do
  begin
   if not fcasesensitive then s := uppercase(varnames^[i])
   else s := varnames^[i];
   if tmp = s then
    begin
      data := i;
      usedvars[i] := true;
      result := F_VAR;
      exit;
    end;
  end;
  ferror := ER_UNKNOWN;
  result := 0;
  exit;
 end;


 if((c>='0')and (c<='9')) then
 begin
  repeat
   tmp := tmp + c;
   inc(pos);
   c := input[pos];
  until not((c>='0')and(c<='9'));

  if(c <> '.') then
  begin
   data := strtofloat(tmp);
   result := F_DATA;
   exit;
  end;

  tmp := tmp + c;
  inc(pos);
  c := input[pos];
  while((c>='0')and(c<='9')) do
  begin
   tmp := tmp + c;
   inc(pos);
   c := input[pos];
  end;

  if((c <> 'E')and(c <> 'e')) then
  begin
   data := strtofloat(tmp);
   result := F_DATA;
   exit;
  end;

  tmp := tmp + c;
  inc(pos);
  c := input[pos];
  if((c = '+')or(c = '-')) then
  begin
   tmp := tmp + c;
   inc(pos);
   c := input[pos];
  end;

  while((c>='0')and(c<='9')) do
  begin
    tmp := tmp + c;
    inc(pos);
    c := input[pos];
  end
 end;

 if c  in ['%','+','-','(',')','*','/', '^', ',','!','=','&','|'] then
 begin
  inc(pos);
  result := byte(c);
  exit;
 end;

 if c = '>' then
 begin
  inc(pos);
  if input[pos] = '=' then
  begin
   inc(pos);
   result := byte(F_GE);
   exit;
  end;
  result := byte(c);
  exit;
 end;

  if c = '<' then
 begin
  inc(pos);
  if input[pos] = '=' then
  begin
   inc(pos);
   result := byte(F_LE);
   exit;
  end;
  if input[pos] = '>' then
  begin
   inc(pos);
   result := byte(F_NE);
   exit;
  end;
  result := byte(c);
  exit;
 end;


 ferror := ER_ILLEGAL;
 result := 0;
 exit;
end;

const err_strings : array [TFormulaError] of string =
('Ok', 'Illegal character', 'Unknown identifier', '")" expected', '"(" expected',
  'Syntax error', 'Variable not used','Not enough parameters');

function TArtFormulaN.ErrString : string;
begin
 result := err_strings[ferror];
end;

function TArtFormulaN.Compile(instr : string; num : byte; vars : PStringArray) : string;
var c: char;
begin
 c := decimalseparator;
 decimalseparator := '.';
 fcompiled := '';
 if not Test(instr, num, vars) then
 begin
  result := '';
  exit;
 end;
 fcompiled := temp;
 result := temp;
 decimalseparator := c;
end;


function TArtFormulaN.ComputeStr(instr : string; num : byte; vars : PStringArray; vals : pdoublearray) : double;
var tmp : string;
begin
 tmp := Compile(instr, num, vars);
 if(tmp = '') then raise FormulaException.Create(ErrString);
 result := Compute(vals);
end;

function TArtFormulaN.Test(instr : string; num : byte; vars : PStringArray) : boolean;
var i:integer;
begin
  if num > 0 then
  begin
   setlength(usedvars,num);
   for i:=0 to num-1 do usedvars[i] := false;
  end;
  input := instr+#0;
  pos := 1;
  numofvar := num;
  varnames := vars;
  temp := '';
 if Form <> F_EOS then
 begin
  if ferror = ER_Ok then ferror := ER_SYNTAX;
  result := false;
  exit;
 end;

 while S.Top <> #0 do
 begin
  temp := temp + S.Popex;
 end;

 if ftestused then
 for i:=0 to num-1 do
  if usedvars[i] = false then
  begin
   ferror := ER_VARS;
   result := false;
   exit;
  end;

 if length(temp) = 0 then
  result := false
 else
  result := true;
end;

function TArtFormulaN.Form:integer;
var p : integer;
    u : ^double;
    i,cnt:integer;
begin
  p := Parser;
  if p = F_EOS then
  begin
   result := 0;
   exit;
  end;

   if chr(p) = '+' then p := Parser;

   if chr(p) = '-' then
   begin
     S.Push(F_UMINUS);
     p := Form;
   end
   else
   if chr(p) = '!' then
   begin
     S.Push('!');
     p := Form;
   end
   else
   if(chr(p) = '(') then
   begin
     S.Push('(');
     p := Form();
     if p = 0 then
     begin
      result := 0;
      exit;
     end;
     if(chr(p) <> ')') then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;

     while(S.Top()<>'(') do
     begin
      temp := temp + S.Popex;
     end;

     S.Pop;
     if isfun(S.Top) then
     begin
      temp := temp + S.Top;
      temp := temp + chr(table[byte(S.Pop)].paramcount)
     end;

     p := Parser;
    end
   else
   if isfun(chr(p)) then
    begin
     S.Push(chr(p));
     cnt := table[p].paramcount;
     if(chr(Parser) <> '(') then
     begin
      ferror := ER_LEFT;
      result := 0;
      exit;
     end;
     S.Push('(');
     if cnt > 0 then
     for i := 1 to cnt do
     begin
      S.Push(',');
      p := Form;
      if p = 0 then
      begin
       result := 0;
       exit;
      end;

      while(S.Top <> ',') do
      begin
       temp := temp + S.Popex;
      end;
      if (chr(p) <> ',') and (i<cnt) then
      begin
       ferror := ER_NOTENOUGH;
       result := 0;
       exit;
      end;
      S.Pop;
     end
     else if cnt = -1 then
     begin
      p := Parser(true);
      cnt := 0;
      while chr(p) <> ')' do
      begin
       inc(cnt);
       S.Push(',');
       p := Form;
       if p = 0 then
       begin
        result := 0;
        exit;
       end;

       while(S.Top <> ',') do
       begin
        temp := temp + S.Popex;
       end;
       S.Pop;
      end;
      temp := temp + chr(F_DATA);
      temp := temp + stringofchar(#0,sizeof(double));
      u := @(temp[length(temp)-sizeof(double)+1]);
      u^ := cnt;
     end
     else p := Parser;
     if chr(p) <> ')' then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;
     while(S.Top <> '(') do
     begin
      temp := temp + S.Popex;
     end;
     S.Pop;
     temp := temp + S.PopEx;
     p := Parser;
    end

   else
   if chr(p) = F_USERF then
    begin
     S.Push(char(trunc(data)));
     S.Push(chr(p));
     p := trunc(data);
     cnt := userfunc[p].paramcount;
     if(chr(Parser) <> '(') then
     begin
      ferror := ER_LEFT;
      result := 0;
      exit;
     end;
     S.Push('(');
     if cnt > 0 then
     for i := 1 to cnt do
     begin
      S.Push(',');
      p := Form;
      if p = 0 then
      begin
       result := 0;
       exit;
      end;

      while(S.Top <> ',') do
      begin
       temp := temp + S.Popex;
      end;
      if (chr(p) <> ',') and (i<cnt) then
      begin
       ferror := ER_NOTENOUGH;
       result := 0;
       exit;
      end;
      S.Pop;
     end
     else p := Parser;

     if chr(p) <> ')' then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;
     while(S.Top <> '(') do
     begin
      temp := temp + S.Popex;
     end;
     S.Pop;
     temp := temp + S.PopEx;
     p := Parser;
    end

   else if p = F_VAR then
    begin
     temp := temp + chr(p);
     temp := temp + chr(trunc(data));
     p := Parser;
    end
   else if p = F_DATA then
    begin
     temp := temp + chr(p);
     temp := temp + stringofchar(#0,sizeof(double));
     u := @(temp[length(temp)-sizeof(double)+1]);
     u^ := data;
     p := Parser;
    end
   else
   begin
    result := 0;
    exit;
   end;


     if p = F_EOS then
     begin
      result :=  F_EOS;
      exit;
     end;
     if not isznak(chr(p)) then
     begin
       result := p;
       exit;
     end;

     while prior(chr(p),S.Top) do temp := temp + S.Popex;
     S.Push(chr(p));
     p := Form;
     if p = 0 then
     begin
       result := 0;
       exit;
     end
     else
     begin
      result := p;
      exit;
     end;
end;

function TArtFormulaN.Compute(vals : pDoubleArray) : double;
var i,idx,l,cnt:integer;
begin
 i := 1;
 l := length(compiled);
 cpos := 0;
 ferror := ER_Ok;

 while(i<=l) do
 begin
   case compiled[i] of
      '+':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos] + cdata[cpos-1];
      end;
      '-':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] - cdata[cpos];
      end;
      '*':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] * cdata[cpos];
      end;
      '/':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] / cdata[cpos];
      end;
      '%':
      begin
       dec(cpos);
       cdata[cpos-1] := trunc(cdata[cpos-1]) mod trunc(cdata[cpos]);
      end;
      '^':
      begin
       dec(cpos);
       cdata[cpos-1] := power(cdata[cpos-1], cdata[cpos]);
      end;
      F_NE :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<>cdata[cpos],1,0);
      end;
      '=' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]=cdata[cpos],1,0);
      end;
      '<' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<cdata[cpos],1,0);
      end;
      F_LE :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<=cdata[cpos],1,0);
      end;
      '>' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]>cdata[cpos],1,0);
      end;
      F_GE:
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]>=cdata[cpos],1,0);
      end;
      F_UMINUS:
      begin
       cdata[cpos-1] := -cdata[cpos-1];
      end;
      '!':
      begin
       cdata[cpos-1] := ifthen(cdata[cpos-1]<>0,1,0);
      end;
      #1 .. chr(NUMFUN-1):
        begin
         idx := byte(compiled[i]);
         inc(i);
         cnt := byte(compiled[i]);
         if cnt = 255 then cnt := trunc(cdata[cpos-1]+1)
         else if cnt = 0 then
         begin
          if cpos = max then
          begin
           inc(max,128);
           setlength(cdata,max);
          end;
          cdata[cpos] := 0;
          inc(cpos);
          cnt := 1;
         end;
         cdata[cpos-cnt] := table[idx].fun(cpos-1, cdata);
         dec(cpos,cnt-1);
        end;
      F_USERF:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         cnt := byte(compiled[i]);
         if cnt = 255 then cnt := trunc(cdata[cpos-1]+1)
         else if (cnt = 0) then
         begin
          if cpos = max then
          begin
           inc(max,128);
           setlength(cdata,max);
          end;
          cdata[cpos] := 0;
          inc(cpos);
          cnt := 1;
         end;
         cdata[cpos-cnt] := userfunc[idx].fun(cpos-1, cdata);
         dec(cpos,cnt-1);
        end;
     chr(F_VAR):
       begin
        inc(i);
        if cpos = max then
        begin
         inc(max,256);
         setlength(cdata,max);
        end;
        cdata[cpos] := vals^[byte(compiled[i])];
        inc(cpos);
       end;
     chr(F_DATA):
       begin
        if cpos = max then
        begin
         inc(max,256);
         setlength(cdata,max);
        end;
        cdata[cpos] := (pdouble(@(compiled[i+1])))^;
        inc(cpos);
        inc(i,sizeof(double));
       end;
     end;
  inc(i);
 end;
 result := cdata[cpos-1];
end;

procedure Register;
begin
  RegisterComponents('Art', [TArtFormulaN]);
end;


end.
